home *** CD-ROM | disk | FTP | other *** search
/ Aminet 2 / Aminet AMIGA CDROM (1994)(Walnut Creek)[Feb 1994][W.O. 44790-1].iso / Aminet / util / gnu / GNU_TILE_FORTH.lha / src / locals.v < prev    next >
Text File  |  1992-05-19  |  5KB  |  198 lines
  1. /*
  2.   C BASED FORTH-83 MULTI-TASKING KERNEL: LOCAL VARIABLES AND ARGUMENT BINDING
  3.  
  4.   Copyright (C) 1988-1990 by Mikael R.K. Patel
  5.  
  6.   Computer Aided Design Laboratory (CADLAB)
  7.   Department of Computer and Information Science
  8.   Linkoping University
  9.   S-581 83 LINKOPING
  10.   SWEDEN
  11.  
  12.   Email: mip@ida.liu.se
  13.  
  14.   Started on: 30 June 1988
  15.  
  16.   Last updated on: 20 April 1990
  17.  
  18.   Dependencies:
  19.        (cc) kernel.c, kernel.h
  20.  
  21.   Description:
  22.     Local variables and argument binding extension vocabulary of
  23.     the tile forth multi-tasking kernel.
  24.  
  25.   Copying:
  26.        This program is free software; you can redistribute it and/or modify
  27.        it under the terms of the GNU General Public License as published by
  28.        the Free Software Foundation; either version 1, or (at your option)
  29.        any later version.
  30.  
  31.        This program is distributed in the hope that it will be useful,
  32.        but WITHOUT ANY WARRANTY; without even the implied warranty of
  33.        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  34.        GNU General Public License for more details.
  35.  
  36.        You should have received a copy of the GNU General Public License
  37.        along with this program; see the file COPYING.  If not, write to
  38.        the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  39.  
  40. */
  41.  
  42. static ENTRY theframed = NIL;
  43.  
  44. VOID doremovelocals()
  45. {
  46.     /* Check if the last definition used an argument definition */
  47.     if (theframed != NIL) {
  48.     
  49.     /* Restore the vocabulary structure */
  50.     spush(theframed, ENTRY);
  51.     dorestore();
  52.     theframed = NIL;
  53.     }
  54. }
  55.  
  56. VOID doparenlink()  
  57. {
  58.     flink();
  59. }
  60.  
  61. COMPILATION_CODE(parenlink, forth, "(link)", doparenlink);
  62.  
  63. VOID doparenunlink()  
  64. {    
  65.     funlink();
  66. }
  67.  
  68. COMPILATION_CODE(parenunlink, parenlink, "(unlink)", doparenunlink);
  69.  
  70. VOID doparenunlinksemicolon() 
  71. {
  72.     funlink();
  73.     fsemicolon();
  74. }
  75.  
  76. COMPILATION_CODE(parenunlinksemicolon, parenunlink, "(unlink;)", doparenunlinksemicolon);
  77.  
  78. VOID doparenunlinkdoes()
  79. {
  80.     funlink();
  81.     fdoes();
  82.     fsemicolon();
  83. }
  84.  
  85. COMPILATION_CODE(parenunlinkdoes, parenunlinksemicolon, "(unlinkdoes>)", doparenunlinkdoes);
  86.  
  87. VOID doparenlocal()
  88. {
  89.     spush(((PTR32) (INT32) fp - *ip++), PTR32);
  90. }
  91.  
  92. COMPILATION_CODE(parenlocal, parenunlinkdoes, "(local)", doparenlocal);
  93.  
  94. VOID doparenlocalstore()
  95. {
  96.     *((PTR32) (INT32) fp - *ip++) = spop(INT32);
  97. }
  98.  
  99. COMPILATION_CODE(parenlocalstore, parenlocal, "(local!)", doparenlocalstore);
  100.  
  101. VOID doparenlocalfetch()
  102. {
  103.     spush(*((PTR32) (INT32) fp - *ip++), INT32);
  104. }
  105.  
  106. COMPILATION_CODE(parenlocalfetch, parenlocalstore, "(local@)", doparenlocalfetch);
  107.  
  108. VOID doassignlocal()
  109. {
  110.     *((PTR32) (INT32) fp - ((ENTRY) *ip++) -> parameter) = spop(INT32);
  111. }
  112.  
  113. COMPILATION_CODE(assignlocal, parenlocalfetch, "->", doassignlocal);
  114.  
  115. COMPILATION_CODE(localexit, assignlocal, "exit", doparenunlinksemicolon);
  116.  
  117. VOID docurlebracket()
  118. {
  119.     BOOL  frameflag = TRUE;
  120.     BOOL  argflag   = TRUE;
  121.     INT32 arguments = 0;
  122.     INT32 locals    = 0;
  123.  
  124.     /* Check only one active lexical levels allowed */
  125.     if (theframed) {
  126.     if (io_source())
  127.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  128.     (VOID) fprintf(io_errf, "%s: illegal argument binding\n", theframed -> name);
  129.     doremovelocals();
  130.     doabort();
  131.     return;
  132.     }
  133.  
  134.     /* Save pointer to latest defintion to allow removal of local names */
  135.     theframed = current -> last;
  136.  
  137.     /* While the end of the frame description is not found */
  138.     while (frameflag) {
  139.  
  140.     /* Scan the next symbol */
  141.         spush(' ', INT32);
  142.     doword();
  143.  
  144.     if (io_eof()) {
  145.         if (io_source())
  146.         (VOID) fprintf(io_errf, "%s:%i:", io_source(), io_line());
  147.         (VOID) fprintf(io_errf, "locals: end of file during scan of parameter list\n");
  148.         doabort();
  149.         return;
  150.     }
  151.  
  152.     /* Check if it marks the end of the argument section */
  153.     if (STREQ(tos.CSTR, "|")) {
  154.         argflag = 0;
  155.     }
  156.     else {
  157.         /* else check if its the end of the frame description */
  158.             if (STREQ(tos.CSTR, "}")) {
  159.             frameflag = FALSE;
  160.         }
  161.         else {
  162.         /* Or the beginning of the return description */
  163.             if (STREQ(tos.CSTR, "--")) {
  164.             sdrop();
  165.             spush('}', INT32);
  166.             doword();
  167.             frameflag = FALSE;
  168.         }
  169.         else {
  170.             /* If not then make the symbol a local variable */
  171.             if (argflag)
  172.             arguments++;
  173.             else
  174.             locals++;
  175.             (VOID) make_entry(tos.CSTR, 
  176.                       (INT32) LOCAL, 
  177.                       (INT32) COMPILATION, 
  178.                       arguments + locals);
  179.         }
  180.         }
  181.     }
  182.     sdrop();
  183.     }
  184.  
  185.     /* Compile the parameter binding linkage */
  186.     spush(&parenlink, CODE_ENTRY);
  187.     dothread();
  188.  
  189.     /* And the appropriate frame size */
  190.     spush(arguments, INT32);
  191.     docomma();
  192.     spush(locals, INT32);
  193.     docomma();
  194. }
  195.  
  196. COMPILATION_IMMEDIATE_CODE(curlebracket, localexit, "{", docurlebracket);
  197.  
  198.